home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Basic / Visual Basic.60 / COMMON / TOOLS / VB / UNSUPPRT / SHELLLNK / SHELLLNK.CLS < prev    next >
Encoding:
Visual Basic class definition  |  1997-01-16  |  10.1 KB  |  214 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "cShellLink"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. '---------------------------------------------------------------
  13. '- Public enums...
  14. '---------------------------------------------------------------
  15. Public Enum STGM
  16.     STGM_DIRECT = &H0&
  17.     STGM_TRANSACTED = &H10000
  18.     STGM_SIMPLE = &H8000000
  19.     STGM_READ = &H0&
  20.     STGM_WRITE = &H1&
  21.     STGM_READWRITE = &H2&
  22.     STGM_SHARE_DENY_NONE = &H40&
  23.     STGM_SHARE_DENY_READ = &H30&
  24.     STGM_SHARE_DENY_WRITE = &H20&
  25.     STGM_SHARE_EXCLUSIVE = &H10&
  26.     STGM_PRIORITY = &H40000
  27.     STGM_DELETEONRELEASE = &H4000000
  28.     STGM_CREATE = &H1000&
  29.     STGM_CONVERT = &H20000
  30.     STGM_FAILIFTHERE = &H0&
  31.     STGM_NOSCRATCH = &H100000
  32. End Enum
  33.  
  34. Public Enum SHELLFOLDERS            ' Shell Folder Path Constants...
  35.     CSIDL_DESKTOP = &H0&            ' ..\WinNT\profiles\username\Desktop
  36.     CSIDL_PROGRAMS = &H2&           ' ..\WinNT\profiles\username\Start Menu\Programs
  37.     CSIDL_CONTROLS = &H3&           ' No Path
  38.     CSIDL_PRINTERS = &H4&           ' No Path
  39.     CSIDL_PERSONAL = &H5&           ' ..\WinNT\profiles\username\Personal
  40.     CSIDL_FAVORITES = &H6&          ' ..\WinNT\profiles\username\Favorites
  41.     CSIDL_STARTUP = &H7&            ' ..\WinNT\profiles\username\Start Menu\Programs\Startup
  42.     CSIDL_RECENT = &H8&             ' ..\WinNT\profiles\username\Recent
  43.     CSIDL_SENDTO = &H9&             ' ..\WinNT\profiles\username\SendTo
  44.     CSIDL_BITBUCKET = &HA&          ' No Path
  45.     CSIDL_STARTMENU = &HB&          ' ..\WinNT\profiles\username\Start Menu
  46.     CSIDL_DESKTOPDIRECTORY = &H10&  ' ..\WinNT\profiles\username\Desktop
  47.     CSIDL_DRIVES = &H11&            ' No Path
  48.     CSIDL_NETWORK = &H12&           ' No Path
  49.     CSIDL_NETHOOD = &H13&           ' ..\WinNT\profiles\username\NetHood
  50.     CSIDL_FONTS = &H14&             ' ..\WinNT\fonts
  51.     CSIDL_TEMPLATES = &H15&         ' ..\WinNT\ShellNew
  52.     CSIDL_COMMON_STARTMENU = &H16&  ' ..\WinNT\profiles\All Users\Start Menu
  53.     CSIDL_COMMON_PROGRAMS = &H17&   ' ..\WinNT\profiles\All Users\Start Menu\Programs
  54.     CSIDL_COMMON_STARTUP = &H18&    ' ..\WinNT\profiles\All Users\Start Menu\Programs\Startup
  55.     CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '..\WinNT\profiles\All Users\Desktop
  56.     CSIDL_APPDATA = &H1A&           ' ..\WinNT\profiles\username\Application Data
  57.     CSIDL_PRINTHOOD = &H1B&         ' ..\WinNT\profiles\username\PrintHood
  58. End Enum
  59.  
  60. Public Enum SHOWCMDFLAGS
  61.     SHOWNORMAL = 5
  62.     SHOWMAXIMIZE = 3
  63.     SHOWMINIMIZE = 7
  64. End Enum
  65.  
  66. '---------------------------------------------------------------
  67. Public Function GetSystemFolderPath(ByVal hwnd As Long, ByVal Id As Integer, sfPath As String) As Long
  68. '---------------------------------------------------------------
  69.     Dim rc As Long                                      ' Return code
  70.     Dim pidl As Long                                    ' ptr to Item ID List
  71.     Dim cbPath As Long                                  ' char count of path
  72.     Dim szPath As String                                ' String var for path
  73. '---------------------------------------------------------------
  74.     szPath = Space(MAX_PATH)                            ' Pre-allocate path string for api call
  75.  
  76.     rc = SHGetSpecialFolderLocation(hwnd, Id, pidl)     ' Get pidl for Id...
  77.     If (rc = 0) Then                                    ' If success is 0
  78. #If UNICODE Then
  79.         rc = SHGetPathFromIDList(pidl, StrPtr(szPath))  ' Get Path from Item Id List
  80. #Else
  81.         rc = SHGetPathFromIDList(pidl, szPath)          ' Get Path from Item Id List
  82. #End If
  83.         If (rc = 1) Then                                ' If success is 1
  84.             szPath = Trim$(szPath)                      ' Fix path string
  85.             cbPath = Len(szPath)                        ' Get length of path
  86.             If (Asc(Right(szPath, 1)) = 0) Then cbPath = cbPath - 1 ' Adjust path length
  87.             If (cbPath > 0) Then sfPath = Left$(szPath, cbPath) ' Adjust path string variable
  88.             GetSystemFolderPath = True                  ' Return success
  89.         End If
  90.     End If
  91. '---------------------------------------------------------------
  92. End Function
  93. '---------------------------------------------------------------
  94.  
  95. '---------------------------------------------------------------
  96. Public Function CreateShellLink(LnkFile As String, ExeFile As String, WorkDir As String, _
  97.                                 ExeArgs As String, IconFile As String, IconIdx As Long, _
  98.                                 ShowCmd As SHOWCMDFLAGS) As Long
  99. '---------------------------------------------------------------
  100.     Dim rc As Long
  101.     Dim pidl As Long                                    ' Item id list
  102.     Dim dwReserved As Long                              ' Reserved flag
  103.     Dim cShellLink As ShellLinkA                        ' An explorer IShellLinkA(Win 95/Win NT) instance
  104.     Dim cPersistFile As IPersistFile                    ' An explorer IPersistFile instance
  105. '---------------------------------------------------------------
  106.     If ((LnkFile = "") Or (ExeFile = "")) Then Exit Function    ' Validate min. input requirements.
  107.     
  108.     On Error GoTo ErrHandler
  109.     Set cShellLink = New ShellLinkA                     ' Create new IShellLink interface
  110.     Set cPersistFile = cShellLink                       ' Implement cShellLink's IPersistFile interface
  111.     
  112.     With cShellLink
  113.         .SetPath ExeFile                                ' set command line exe name & path to new ShortCut.
  114.         
  115.         If (WorkDir <> "") Then .SetWorkingDirectory WorkDir ' Set working directory in shortcut
  116.         
  117.         If (ExeArgs <> "") Then .SetArguments ExeArgs   ' Add arguments to command line
  118.         
  119. '       if (LnkDesc <> "") then .SetDescription pszName ' Set shortcut description
  120. '       .SetHotkey wHotKey
  121.        
  122.         If (IconFile <> "") Then .SetIconLocation IconFile, IconIdx ' Set shortcut icon location & index
  123.         
  124.         .SetDescription "ShellLink Sample" & vbNullChar
  125. '       .SetIDList pidl
  126. '       dwReserved = 0
  127. '       .SetRelativePath pszPathRel, dwReserved
  128.  
  129.         .SetShowCmd ShowCmd                             ' Set shortcut's startup mode (min,max,normal)
  130.     End With
  131.     
  132.     cShellLink.Resolve 0, SLR_UPDATE
  133.     cPersistFile.Save StrConv(LnkFile, vbUnicode), 0    ' Unicode conversion hack... This must be done!
  134.     CreateShellLink = True                              ' Return Success
  135.  
  136. '---------------------------------------------------------------
  137. ErrHandler:
  138. '---------------------------------------------------------------
  139.     Set cPersistFile = Nothing                          ' Destroy Object
  140.     Set cShellLink = Nothing                            ' Destroy Object
  141. '---------------------------------------------------------------
  142. End Function
  143. '---------------------------------------------------------------
  144.  
  145. '---------------------------------------------------------------
  146. Public Function GetShellLinkInfo(LnkFile As String, ExeFile As String, WorkDir As String, _
  147.                                  ExeArgs As String, IconFile As String, IconIdx As Long, _
  148.                                  ShowCmd As Long) As Long
  149. '---------------------------------------------------------------
  150.     Dim pidl As Long                                    ' Item id list
  151.     Dim wHotKey As Long                                 ' Hotkey to shortcut...
  152.     Dim fd As WIN32_FIND_DATA
  153.     Dim Description As String
  154.     Dim buffLen As Long
  155.     Dim cShellLink As ShellLinkA                        ' An explorer IShellLink instance
  156.     Dim cPersistFile As IPersistFile                    ' An explorer IPersistFile instance
  157. '---------------------------------------------------------------
  158.     If (LnkFile = "") Then Exit Function                ' Validate min. input requirements.
  159.     
  160.     Set cShellLink = New ShellLinkA                     ' Create new IShellLink interface
  161.     Set cPersistFile = cShellLink                       ' Implement cShellLink's IPersistFile interface
  162.     
  163.     ' Load Shortcut file...(must do this UNICODE hack!)
  164.     On Error GoTo ErrHandler
  165.     cPersistFile.Load StrConv(LnkFile, vbUnicode), STGM_DIRECT
  166.     
  167.     With cShellLink
  168.         ' Get command line exe name & path of shortcut
  169.         ExeFile = Space(MAX_PATH)
  170.         buffLen = Len(ExeFile)
  171.         .GetPath ExeFile, buffLen, fd, SLGP_UNCPRIORITY
  172.         Dim s As String
  173.         s = fd.cFileName                                ' Not returned to calling function
  174.         
  175.         ' Get working directory of shortcut
  176.         WorkDir = Space(MAX_PATH)
  177.         buffLen = Len(WorkDir)
  178.         .GetWorkingDirectory WorkDir, buffLen
  179.         
  180.         ' Get command line arguments of shortcut
  181.         ExeArgs = Space(MAX_PATH)
  182.         buffLen = Len(ExeArgs)
  183.         .GetArguments ExeArgs, buffLen
  184.         
  185.         ' Get description of shortcut
  186.         Description = Space(MAX_PATH)
  187.         buffLen = Len(Description)
  188.         .GetDescription Description, buffLen            ' Not returned to calling function
  189.         
  190.         ' Get the HotKey for shortcut
  191.         .GetHotkey wHotKey                              ' Not returned to calling function
  192.        
  193.         ' Get shortcut icon location & index
  194.         IconFile = Space(MAX_PATH)
  195.         buffLen = Len(IconFile)
  196.         .GetIconLocation IconFile, buffLen, IconIdx
  197.         
  198.         ' Get Item ID List...
  199.         .GetIDList pidl                                 ' Not returned to calling function
  200.                 
  201.         ' Set shortcut's startup mode (min,max,normal)
  202.         .GetShowCmd ShowCmd
  203.     End With
  204.  
  205.     GetShellLinkInfo = True                             ' Return Success
  206. '---------------------------------------------------------------
  207. ErrHandler:
  208. '---------------------------------------------------------------
  209.     Set cPersistFile = Nothing                          ' Destroy Object
  210.     Set cShellLink = Nothing                            ' Destroy Object
  211. '---------------------------------------------------------------
  212. End Function
  213. '---------------------------------------------------------------
  214.